home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / graphics / rgbcolor / crgbcolr.cls < prev    next >
Text File  |  1996-01-05  |  7KB  |  323 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "RGBColor"
  6. Attribute VB_Creatable = False
  7. Attribute VB_Exposed = False
  8. '-- RGBColor Class
  9. '-- Copyright ⌐ 1995-1996 Gregg Irwin. All Rights Reserved
  10.  
  11. Option Explicit
  12. DefInt A-Z
  13.  
  14. #If Win16 Then
  15.     Private Declare Function GetNearestColor Lib "gdi" (ByVal hDC As Integer, ByVal RGBColor As Long) As Long
  16.     Private Declare Function GetSysColor Lib "user" (ByVal nIndex As Integer) As Long
  17. #ElseIf Win32 Then
  18.     Private Declare Function GetNearestColor Lib "gdi32" (ByVal hDC As Long, ByVal RGBColor As Long) As Long
  19.     Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
  20. #End If
  21.  
  22.  
  23. '-- We can't use the Type def's in our public interface functions
  24. '   where they would be most useful, and we don't need them for
  25. '   any internal functions, so they're just here as documentation
  26. '   of the API Type structure.
  27.  
  28. 'Private Type T_RGBQuad
  29. '    Blue    As Byte
  30. '    Green   As Byte
  31. '    Red     As Byte
  32. '    Rsvd    As Byte
  33. 'End Type
  34. '
  35. 'Private Type T_RGBTriple
  36. '    Blue    As Byte
  37. '    Green   As Byte
  38. '    Red     As Byte
  39. 'End Type
  40.  
  41. Const COLOR_DEFBITON = &H80000000    ' bit set -> Win SysColor, not RGB
  42.  
  43. Private mValue As Long     ' Color value
  44.  
  45. '* PROPERTIES   *
  46. ' .BlueValue
  47. ' .GreenValue
  48. ' .RedValue
  49. ' .Value
  50.  
  51. '* METHODS      *
  52. ' .AsHexString
  53. ' .AsRgbQuad
  54. ' .AsRGBString
  55. ' .AsRgbTriple
  56. ' .FromHexString
  57. ' .FromRGBString
  58. ' .NearestSolidColor
  59.  
  60.  
  61. '---------------------------------------------------
  62. '-- PROPERTIES
  63. '---------------------------------------------------
  64.  
  65. ' .BlueValue
  66. Public Property Let BlueValue(B As Integer)
  67.  
  68.     Call SetBValue(B)
  69.  
  70. End Property
  71.  
  72. Public Property Get BlueValue() As Integer
  73.  
  74.     BlueValue = GetBValue(Value)
  75.  
  76. End Property
  77.  
  78.  
  79. ' .GreenValue
  80. Public Property Let GreenValue(G As Integer)
  81.  
  82.     Call SetGValue(G)
  83.  
  84. End Property
  85.  
  86. Public Property Get GreenValue() As Integer
  87.  
  88.     GreenValue = GetGValue(Value)
  89.  
  90. End Property
  91.  
  92.  
  93. ' .RedValue
  94. Public Property Let RedValue(R As Integer)
  95.  
  96.     Call SetRValue(R)
  97.  
  98. End Property
  99.  
  100. Public Property Get RedValue() As Integer
  101.  
  102.     RedValue = GetRValue(Value)
  103.  
  104. End Property
  105.  
  106.  
  107. ' .Value
  108. Public Property Let Value(NewColor As Long)
  109.     
  110.     '-- If the high bit is set then it's a system color
  111.     If NewColor And COLOR_DEFBITON Then
  112.         mValue = GetSysColor(NewColor And &HFFFFFF)
  113.     Else
  114.         mValue = NewColor
  115.     End If
  116.     
  117. End Property
  118.  
  119. Public Property Get Value() As Long
  120.     
  121.     Value = mValue
  122.     
  123. End Property
  124.  
  125.  
  126. '---------------------------------------------------
  127. '-- METHODS
  128. '---------------------------------------------------
  129.  
  130. ' .AsHexString
  131. Public Function AsHexString() As String
  132.  
  133.     AsHexString = Hex$(Value)
  134.  
  135. End Function
  136.  
  137.  
  138. ' .AsRgbQuad
  139. Public Function AsRGBQuad() As Variant
  140.  
  141.     '-- We can't use a Type in a public interface so
  142.     '   we return the 4 bytes in an array.
  143.     AsRGBQuad = Array(CByte(BlueValue), _
  144.                       CByte(GreenValue), _
  145.                       CByte(RedValue), _
  146.                       CByte(0))
  147.  
  148. End Function
  149.  
  150. ' .AsRGBString
  151. Public Function AsRGBString() As String
  152.  
  153.     AsRGBString = RGBStrFromColor(Value)
  154.     
  155. End Function
  156.  
  157.  
  158. ' .AsRgbTriple
  159. Public Function AsRGBTriple() As Variant
  160.  
  161.     '-- We can't use a Type in a public interface so
  162.     '   we return the 3 bytes in an array.
  163.     AsRGBTriple = Array(CByte(BlueValue), _
  164.                         CByte(GreenValue), _
  165.                         CByte(RedValue))
  166.  
  167. End Function
  168.  
  169.  
  170. ' .FromHexString
  171. Public Sub FromHexString(HexStr As String)
  172.  
  173.     Value = ColorFromHexStr(HexStr)
  174.  
  175. End Sub
  176.  
  177.  
  178. ' .FromRGBString
  179. Public Sub FromRGBString(RGBStr As String)
  180.  
  181.     Value = ColorFromRGBStr(RGBStr)
  182.  
  183. End Sub
  184.  
  185.  
  186. ' .NearestSolidColor
  187. Public Function NearestSolidColor(hDC As Long) As Long
  188.  
  189.     NearestSolidColor = GetNearestColor(hDC, Value)
  190.     
  191. End Function
  192.  
  193.  
  194. '------------------------------------------------
  195. '-- INTERNAL SUPPORT PROCEDURES
  196. '------------------------------------------------
  197.  
  198. ' .ColorFromHexStr
  199. Private Function ColorFromHexStr(ByVal HexStr As String) As Long
  200.     Dim tmpColor As Long
  201.     
  202.     '-- Prepend hex identifier if necessary (Val requires this)
  203.     If Left$(UCase$(HexStr), 2) <> "&H" Then
  204.         HexStr = "&H" & HexStr
  205.     End If
  206.     
  207.     '-- Append trailing ampersand so value is cast to a long.
  208.     '   This prevents overflow errors from the Val function.
  209.     If Right(HexStr, 1) <> "&" Then
  210.         HexStr = HexStr & "&"
  211.     End If
  212.  
  213.     '-- This isn't necessarily a real color value yet. It could be
  214.     '   a system color. Converting it at this point lets us check
  215.     '   the value to see if the high bit is set, indicating that
  216.     '   it's a system color.
  217.     tmpColor = Val(HexStr)
  218.  
  219.     '-- If the high bit is set then it's a system color,
  220.     '   otherwise it's an RGB value.
  221.     If tmpColor And COLOR_DEFBITON Then
  222.         ColorFromHexStr = GetSysColor(tmpColor And &HFFFFFF)
  223.     Else
  224.         ColorFromHexStr = tmpColor
  225.     End If
  226.  
  227. End Function
  228.  
  229.  
  230. ' .ColorFromRGBStr
  231. Private Function ColorFromRGBStr(RGBStr As String) As Long
  232. '------------------------------------------------
  233. '-- Acceptable Color formats: 255 255 255
  234. '                             255, 255, 255
  235. '------------------------------------------------
  236.     Dim RVal    As Long
  237.     Dim GVal    As Long
  238.     Dim BVal    As Long
  239.     Dim NextSpc As Integer
  240.     Dim LastSpc As Integer
  241.     
  242.     On Error Resume Next
  243.         LastSpc = 1
  244.         NextSpc = InStr(RGBStr, " ")
  245.         RVal = Val(Mid$(RGBStr, LastSpc, NextSpc - LastSpc))
  246.         LastSpc = NextSpc
  247.         
  248.         NextSpc = InStr(LastSpc + 1, RGBStr, " ")
  249.         GVal = Val(Mid$(RGBStr, LastSpc, NextSpc - LastSpc))
  250.         LastSpc = NextSpc
  251.         
  252.         NextSpc = Len(RGBStr) + 1
  253.         BVal = Val(Mid$(RGBStr, LastSpc, NextSpc - LastSpc))
  254.     On Error GoTo 0
  255.  
  256.     ColorFromRGBStr = RVal + (GVal * &H100) + (BVal * &H10000)
  257.  
  258. End Function
  259.  
  260.  
  261. ' .GetBValue
  262. Private Function GetBValue(Color As Long) As Integer
  263.     
  264.     GetBValue = (Color \ &H10000) And &HFF
  265.  
  266. End Function
  267.  
  268.  
  269. ' .GetGValue
  270. Private Function GetGValue(Color As Long) As Integer
  271.     
  272.     GetGValue = (Color \ &H100) And &HFF
  273.  
  274. End Function
  275.  
  276.  
  277. ' .GetRValue
  278. Private Function GetRValue(Color As Long) As Integer
  279.     
  280.     GetRValue = Color& And &HFF
  281.  
  282. End Function
  283.  
  284.  
  285. ' .RGBStrFromColor
  286. Private Function RGBStrFromColor(Color As Long) As String
  287.     Dim RVal As String
  288.     Dim GVal As String
  289.     Dim BVal As String
  290.  
  291.     RVal = CStr(GetRValue(Color))
  292.     GVal = CStr(GetGValue(Color))
  293.     BVal = CStr(GetBValue(Color))
  294.     
  295.     RGBStrFromColor = RVal & " " & GVal & " " & BVal
  296.  
  297. End Function
  298.  
  299.  
  300. ' .SetBValue
  301. Private Sub SetBValue(B As Integer)
  302.     
  303.     mValue = RGB(RedValue, GreenValue, B)
  304.  
  305. End Sub
  306.  
  307.  
  308. ' .SetGValue
  309. Private Sub SetGValue(G As Integer)
  310.     
  311.     mValue = RGB(RedValue, G, BlueValue)
  312.  
  313. End Sub
  314.  
  315.  
  316. ' .SetRValue
  317. Private Sub SetRValue(R As Integer)
  318.     
  319.     mValue = RGB(R, GreenValue, BlueValue)
  320.  
  321. End Sub
  322.  
  323.